home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _e0b65c8ec2a562c9f9c23ea375d1f01c < prev    next >
Encoding:
Text File  |  2002-05-30  |  11.1 KB  |  436 lines
  1. package Tk::Adjuster;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = '3.025'; # $Id: //depot/Tk8/Tk/Adjuster.pm#25 $
  5.  
  6. use base  qw(Tk::Frame);
  7.  
  8. # We cannot do this :
  9.  
  10. # Construct Tk::Widget 'packAdjust';
  11.  
  12. # because if managed object is Derived (e.g. a Scrolled) then our 'new'
  13. # will be delegated and hierachy gets turned inside-out
  14. # So packAdjust is autoloaded in Widget.pm
  15.  
  16.  
  17. Construct Tk::Widget qw(Adjuster);
  18.  
  19. {package Tk::Adjuster::Item;
  20.  
  21. use strict;
  22. use base  qw(Tk::Frame);
  23.  
  24. sub ClassInit
  25. {
  26.  my ($class,$mw) = @_;
  27.  $mw->bind($class,'<1>',['BDown', 1]);
  28.  $mw->bind($class,'<Shift-1>',['BDown', 0]);
  29.  $mw->bind($class,'<B1-Motion>',['Motion',1]);
  30.  $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]);
  31.  $mw->bind($class,'<ButtonRelease-1>',['Motion',0]);
  32.  return $class;
  33. }
  34.  
  35. sub BDown
  36. {
  37.  my($w, $delay_mask) = @_;
  38.  $w->{'start_x'} = $w->XEvent->x;
  39.  $w->{'start_y'} = $w->XEvent->y;
  40.  my $adj  = $w->Parent;
  41.  delete $adj->{'lin_info'};
  42.  my $delay = $delay_mask && $adj->cget('-delay');
  43.  if ($delay)
  44.   {
  45.     $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0);
  46.   }
  47. }
  48.  
  49. sub Motion
  50. {
  51.  my($w, $delay_mask) = @_;
  52.  my $ev = $w->XEvent;
  53.  my $adj  = $w->Parent;
  54.  
  55.  my $delay = $delay_mask && $adj->cget('-delay');
  56.  if ($adj->vert)
  57.   {
  58.     my $dx = $ev->x - $w->{'start_x'};
  59.     $delay ?  $adj->delta_width_bar($dx) : $adj->delta_width($dx);
  60.   }
  61.  else
  62.   {
  63.     my $dy = $ev->y - $w->{'start_y'};
  64.     $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy);
  65.   }
  66. }
  67.  
  68. }
  69.  
  70.  
  71.  
  72. sub packAfter
  73. {
  74.  my ($w,$s,%args) = @_;
  75.  my $side = $args{'-side'} ? $args{'-side'} : 'top';
  76.  $w->configure(-side   => $side, -widget => $s);
  77.  $w->packed($s, %args);
  78. }
  79.  
  80. sub packForget
  81. {
  82.  my ($w,$forget_slave) = @_;
  83.  $w->Tk::Widget::packForget;
  84.  $w->slave->packForget if $forget_slave;
  85. }
  86.  
  87. # Called by Tk::Widget::packAdjust. It was here before packAfter was added
  88. sub packed
  89. {
  90.  my ($w,$s,%args) = @_;
  91.  delete $args{'-before'};
  92.  $args{'-expand'} = 0;
  93.  $args{'-after'} = $s;
  94.  $args{'-fill'} = (($w->vert) ? 'y' : 'x');
  95.  $w->pack(%args);
  96. }
  97.  
  98. sub gridded
  99. {
  100.  my ($w,$s,%args) = @_;
  101.  # delete $args{'-before'};
  102.  # $args{'-expand'} = 0;
  103.  # $args{'-after'} = $s;
  104.  # $args{'-fill'} = (($w->vert) ? 'y' : 'x');
  105.  $w->grid(%args);
  106. }
  107.  
  108. sub ClassInit
  109. {
  110.  my ($class,$mw) = @_;
  111.  $mw->bind($class,'<Configure>','SizeChange');
  112.  $mw->bind($class,'<Unmap>','Restore');
  113.  $mw->bind($class,'<Map>','Mapped');
  114.  return $class;
  115. }
  116.  
  117. sub SizeChange
  118. {
  119.  my $w = shift;
  120.  # reqwidth/height of Adjuster is stored here. If it is partially pushed out
  121.  # of the window, then $w->width/height returns that of the visible part.
  122.  if ($w->vert)
  123.   {
  124.    my $sx = ($w->Width - $w->{'sep'}->Width)/2;
  125.    $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18);
  126.    $w->{'sep'}->place('-x' => $sx, '-y' => 0,  -relheight => 1);
  127.    $w->configure(-width => $w->{'but'}->ReqWidth);
  128.    $w->{'reqwidth'} = $w->reqwidth;
  129.   }
  130.  else
  131.   {
  132.    my $sy = ($w->Height - $w->{'sep'}->Height)/2;
  133.    $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0);
  134.    $w->{'sep'}->place('-x' => 0, '-y' => $sy,  -relwidth => 1);
  135.    $w->configure(-height => $w->{'but'}->ReqHeight);
  136.    $w->{'reqheight'} = $w->reqheight;
  137.   }
  138.  # Turn off geometry propagation in the slave. Do only if necessary, as this
  139.  # causes repacking.
  140.  my $s = $w->slave;
  141.  $s->packPropagate('0') if $s->packSlaves && $s->packPropagate();
  142.  $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate();
  143. }
  144.  
  145. sub Mapped
  146. {
  147.  my $w = shift;
  148.  $w->idletasks;
  149.  my $m = $w->manager;
  150.  if ($m =~ /^(?:pack|grid)$/)
  151.   {
  152.    my %info = $w->$m('info');
  153.    my $master = $info{'-in'};
  154.    $master->$m('propagate',0);
  155.    $w->{'master'} = $master;
  156.   }
  157.  $w->slave_expand_off;
  158. }
  159.  
  160. sub Populate
  161. {
  162.  my ($w,$args) = @_;
  163.  $w->SUPER::Populate($args);
  164.  $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken');
  165.  $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised');
  166.  
  167.  # Need to explicitly set frame width to 0 for Win32
  168.  my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0);
  169.  
  170.  my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
  171.                  -side       => ['METHOD','side','Side','top'],
  172.                  -delay      => ['PASSIVE','delay','Delay', 1],
  173.                  -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef],
  174.                  -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'],
  175.          -restore    => ['PASSIVE','restore', 'Restore', 1],
  176.                 ); 
  177.  $w->_OnDestroy(qw(sep but lin master));
  178. }
  179.  
  180. sub side
  181. {
  182.  my ($w,$val) = @_;
  183.  if (@_ > 1)
  184.   {
  185.    $w->{'side'} = $val;
  186.    my $cursor;
  187.    if ($w->vert)
  188.     {
  189.      $cursor = 'sb_h_double_arrow';
  190.      $w->{'sep'}->configure(-width => 2, -height => 10000);
  191.     }
  192.    else
  193.     {
  194.      $cursor = 'sb_v_double_arrow';
  195.      $w->{'sep'}->configure(-height => 2, -width => 10000);
  196.     }
  197.    my $x;
  198.    foreach $x ($w->{'sep'},$w->{'but'})
  199.     {
  200.      $x->configure(-cursor => $cursor);
  201.     }
  202.   }
  203.  return $w->{'side'};
  204. }
  205.  
  206. sub slave
  207. {
  208.  my $w = shift;
  209.  my $s = $w->cget('-widget');
  210.  return $s;
  211. }
  212.  
  213. sub vert
  214. {
  215.  my $w = shift;
  216.  my $side = $w->cget('-side');
  217.  return  1 if $side eq 'left';
  218.  return -1 if $side eq 'right';
  219.  return  0;
  220. }
  221.  
  222. # If the Adjuster gets unmapped, it attempts to restore itself. If its
  223. # slave is mapped, then it reduces the size of the slave so that there is
  224. # then room in the master for the Adjuster widget.
  225. sub Restore
  226. {
  227.  my $w = shift;
  228.  return if ! $w->toplevel->IsMapped ||
  229.         ! $w->slave->IsMapped ||
  230.        ! $w->cget('-restore');
  231.  $w->vert ? $w->delta_width(0) : $w->delta_height(0);
  232. }
  233.  
  234. sub delta_width_bar
  235. {
  236.  my ($w,$dx) = @_;
  237.  my $l = $w->{'lin'};
  238.  my $r = $w->{'sep'};
  239.  my $t = $w->toplevel;
  240.  my $m = $w->{'master'};
  241.  my $s = $w->slave;
  242.  my ($min_rootx, $max_rootx, $t_border);
  243.  if (! $w->{'lin_info'})
  244.   {
  245.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  246.    $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
  247.    if ($w->cget('-side') eq 'right')
  248.     {
  249.      $min_rootx = $m->rootx + $m_border;
  250.      $max_rootx = $s->rootx + $s->width - 1;
  251.     }
  252.    else
  253.     {
  254.      $min_rootx = $s->rootx;
  255.      $max_rootx = $m->rootx + $m->width - $m_border - 1;
  256.     }
  257.    $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border];
  258.   }
  259.   else
  260.    {
  261.     ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}};
  262.    }
  263.  $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped;
  264.  
  265.  my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx;
  266.  $new_rootx = $min_rootx if $new_rootx < $min_rootx;
  267.  $new_rootx = $max_rootx if $new_rootx > $max_rootx;
  268.  my $placex = $new_rootx - $t->rootx - $t_border;
  269.  my $placey = $w->rooty  - $t->rooty - $t_border;
  270.  $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey);
  271.  my $this = $w->containing($new_rootx, $w->rooty + 1);
  272.  $l->raise($this) if $this && $this ne $t;
  273. }
  274.  
  275. sub delta_width
  276. {
  277.  my ($w,$dx) = @_;
  278.  my $l = $w->{'lin'};
  279.  $l->placeForget;
  280.  my $s = $w->slave;
  281.  if ($s)
  282.   {
  283.    my $m = $w->{'master'};
  284.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  285.    my $w_width = $w->{'reqwidth'};
  286.    my $m_width = $m->width;
  287.    my $s_width = $s->width;
  288.    my $max_width = $m_width - $w_width;
  289.    my $max_s_width;
  290.    if ($w->cget('-side') eq 'right')
  291.     {
  292.      $dx = -$dx;
  293.      $max_s_width = $max_width -
  294.               ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border;
  295.     }
  296.    else
  297.     {
  298.      $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border;
  299.     }
  300.    my $new_width = $s_width+$dx;
  301.    $new_width = $max_s_width if $new_width > $max_s_width;
  302.    $new_width = 0 if $new_width < 0;
  303.    $s->GeometryRequest($new_width, $s->height);
  304.   }
  305. }
  306.  
  307. sub delta_height_bar
  308. {
  309.  my ($w,$dy) = @_;
  310.  my $l = $w->{'lin'};
  311.  my $r = $w->{'sep'};
  312.  my $t = $w->toplevel;
  313.  my $m = $w->{'master'};
  314.  my $s = $w->slave;
  315.  my ($min_rooty, $max_rooty, $t_border);
  316.  if (! $w->{'lin_info'})
  317.   {
  318.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  319.    $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
  320.    if ($w->cget('-side') eq 'bottom')
  321.     {
  322.      $min_rooty = $m->rooty + $m_border;
  323.      $max_rooty = $s->rooty + $s->height - 1;
  324.     }
  325.    else
  326.     {
  327.      $min_rooty = $s->rooty;
  328.      $max_rooty = $m->rooty + $m->height - $m_border - 1;
  329.     }
  330.    $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border];
  331.   }
  332.  else
  333.   {
  334.    ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}};
  335.   }
  336.  $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped;
  337.  
  338.  my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy;
  339.  $new_rooty = $min_rooty if $new_rooty < $min_rooty;
  340.  $new_rooty = $max_rooty if $new_rooty > $max_rooty;
  341.  my $placey = $new_rooty - $t->rooty - $t_border;
  342.  my $placex = $w->rootx  - $t->rootx - $t_border;
  343.  $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey);
  344.  my $this = $w->containing($w->rootx + 1, $new_rooty);
  345.  $l->raise($this) if $this && $this ne $t;
  346. }
  347.  
  348. sub delta_height
  349. {
  350.  my ($w,$dy) = @_;
  351.  my $l = $w->{'lin'};
  352.  $l->placeForget;
  353.  my $s = $w->slave;
  354.  if ($s)
  355.   {
  356.    my $m = $w->{'master'};
  357.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  358.    my $w_height = $w->{'reqheight'};
  359.    my $m_height = $m->height;
  360.    my $s_height = $s->height;
  361.    my $max_height = $m_height - $w_height;
  362.    my $max_s_height;
  363.    if ($w->cget('-side') eq 'bottom')
  364.     {
  365.      $dy = -$dy;
  366.      $max_s_height = $max_height -
  367.             ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border;
  368.     }
  369.    else
  370.     {
  371.      $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border;
  372.     }
  373.    my $new_height = $s_height+$dy;
  374.  
  375.    $new_height = $max_s_height if $new_height > $max_s_height;
  376.    $new_height = 0 if $new_height < 0;
  377.    $s->GeometryRequest($s->width, $new_height);
  378.   }
  379. }
  380.  
  381. # Turn off expansion in the slave.
  382. # This is done only if necessary, as calls to pack/gridConfigure cause
  383. # repacking.
  384. # Before call to pack/gridConfigure, the reqwidth/reqheight is set to the
  385. # current width/height. This is because the geometry managers use
  386. # the requested values, not the actual, to calculate the new geometry.
  387. sub slave_expand_off
  388. {
  389.  my $w = shift;
  390.  my $s = $w->slave;
  391.  return if ! $s;
  392.  
  393.  my $manager = $s->manager;
  394.  if ($manager eq 'pack')
  395.   {
  396.    my %info = $s->packInfo;
  397.    my $expand = $info{'-expand'};
  398.    if ($expand)
  399.     {
  400.      $s->GeometryRequest($s->width, $s->height);
  401.      $s->packConfigure(-expand => 0);
  402.     }
  403.   }
  404.  elsif ($manager eq 'grid')
  405.   {
  406.    my %info = $s->gridInfo;
  407.    my $master = $info{'-in'};
  408.    if ($w->vert)
  409.     {
  410.      my $col = $info{'-column'};
  411.      my $expand = $master->gridColumnconfigure($col, '-weight');
  412.      if ($expand)
  413.       {
  414.        $s->GeometryRequest($s->width, $s->height);
  415.        $master->gridColumnconfigure($col, -weight => 0);
  416.       }
  417.     }
  418.    else
  419.     {
  420.      my $row = $info{'-row'};
  421.      my $expand = $master->gridRowconfigure($row, '-weight');
  422.      if ($expand)
  423.       {
  424.        $s->GeometryRequest($s->width, $s->height);
  425.        $master->gridRowconfigure($row, -weight => 0);
  426.       }
  427.     }
  428.   }
  429. }
  430.  
  431. 1;
  432.  
  433. __END__
  434.  
  435. =cut #' emacs hilighting...
  436.